home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / SystemCode / DblClickAux.tcl < prev    next >
Text File  |  1996-08-15  |  13KB  |  399 lines
  1. #############################################################################
  2. # File:    DblClickAux.tcl
  3. #
  4. #          General utility procs (originally for TeX, BibTeX and Perl modes)
  5. #
  6. # Authors: Tom Pollard <pollard@chem.columbia.edu>
  7. #          Tom Scavo   <trscavo@syr.edu>
  8. #
  9. #############################################################################
  10.  
  11. #############################################################################
  12. # Take any valid Macintosh filespec as input, and return the
  13. # corresponding absolute filespec.  Filenames without an explicit
  14. # folder are resolved relative to the folder of the current document.
  15. #
  16. proc absolutePath {filename}    {
  17.     set    name [file tail    $filename]
  18.     set    subdir [file dirname $filename]
  19.     if { [string length $subdir] > 0 && [string index $subdir 0] != ":" } {
  20.         set    dir    ""
  21.     } else {
  22.         set    dir    [file dirname [lindex [winNames    -f]    0]]
  23.     }
  24.     return    "$dir$subdir:$name"
  25. }
  26.  
  27. #############################################################################
  28. # Open the file specified by the full pathname "$filename"
  29. # If it's already open, just switch to it without any fuss.
  30. #
  31. proc openFileQuietly {filename}    {
  32.     if {[lsearch [winNames -f]    $filename] >= 0} {
  33.         bringToFront $filename
  34.     } elseif {[file exists $filename]} {
  35.         edit -w    $filename
  36.     } else {
  37.         error "Couldn''t find ¥"$filename¥""
  38.     }
  39. }
  40.  
  41. #############################################################################
  42. # Searches $filename for the given pattern $searchString.  If the 
  43. # search is successful, returns the matched string; otherwise returns
  44. # the empty string.  If the flag 'indices' is true and the search is
  45. # successful, returns a list of two pos giving the indices of the
  46. # found string; otherwise returns the list '-1 -1'.
  47. #
  48. proc searchInFile {filename searchString {indices 0}} {
  49.     # Get the text of the file to be searched:
  50.     if {[lsearch [winNames -f]    $filename] >= 0} {
  51.         set fileText [getText -w $filename 0 [maxPos -w $filename]]
  52.     } elseif {[file exists $filename]} {
  53.         set fd [open $filename]
  54.         set fileText [read $fd]
  55.         close $fd
  56.     } else {
  57.         if { $indices } {
  58.             return [list -1 -1]
  59.         } else {
  60.             return ""
  61.         }
  62.     }
  63.     # Search the text for the search string:
  64.     if { $indices } {
  65.         if {[regexp -indices $searchString $fileText mtch]} {
  66.             # Fixes an apparent bug in 'regexp':
  67.             return [list [lindex $mtch 0] [expr [lindex $mtch 1] + 1]]
  68.         } else {        
  69.             return [list -1 -1]
  70.         }
  71.     } else {
  72.         if {[regexp $searchString $fileText mtch]} {
  73.             return $mtch
  74.         } else {        
  75.             return ""
  76.         }
  77.     }
  78. }
  79.  
  80. #############################################################################
  81. #  Read and return the complete contents of the specified file.
  82. #
  83. proc readFile {fileName} {
  84.     if {[file exists $fileName] && [file readable $fileName]} {
  85.        set fileid [open $fileName "r"]
  86.        set contents [read $fileid]
  87.        close $fileid
  88.        return $contents
  89.     } else {
  90.        error "No readable file found"
  91.     }
  92. }
  93.  
  94. #############################################################################
  95. #  Save $text in $filename.  If $text is null, create an empty file.
  96. #  Overwrite if $overwrite is true or the file does not exist; 
  97. #  otherwise, prompt the user.
  98. #
  99. proc writeFile {filename {text {}} {overwrite 0}} {
  100.     if { $overwrite || ![file exists $filename] } {
  101.         message "Saving $filenameﾉ"
  102.         set fd [open $filename "w"]
  103.         puts $fd $text
  104.         close $fd
  105.     } else {
  106.         switch [askyesno "File $filename exists!  Overwrite?"] {
  107.             "yes" {
  108.                 writeFile $filename $text 1
  109.             }
  110.             "no" {
  111.                 message "No file written"
  112.             }
  113.         }
  114.     }
  115. }
  116.  
  117.  
  118. #############################################################################
  119. #  Highlight (select) a particular line in the designated file, opening the
  120. #  file if necessary.  Returns the full name of the buffer containing the
  121. #  opened file.  If provided, a message is displayed on the status line.
  122. #
  123. proc gotoFileLine {fname line {mesg {}}} {
  124.     if {[expr {[lsearch [winNames -f] "*$fname"] >= 0}]} {
  125.         bringToFront $fname
  126.     } elseif {[expr {[lsearch [winNames] "*$fname"] >= 0}]} {
  127.         bringToFront $fname
  128.     } elseif {[file exists $fname]} {
  129.         edit $fname
  130.         catch {shrinkWindow 2}
  131.     } else {
  132.         alertnote "File ¥" $fname ¥" not found."
  133.         return
  134.     }
  135.     set pos [rowColToPos $line 0]
  136.     select [lineStart $pos] [nextLineStart $pos]
  137.     if {[string length $mesg]} { message $mesg }
  138.     return [lindex [winNames -f] 0]
  139. }
  140.  
  141. ###########################################################################
  142. #  Parse a string into "word"s, which include blocks of non-space text,
  143. #  double- and single-quoted strings, and blocks of text enclosed in 
  144. #  balanced parentheses or curly brackets.
  145. #
  146. #  If a word is delimited by a quote or paren character (¥", ¥', ¥(, or ¥{),
  147. #  then _that_ particular delimiter may be included within the word if it is 
  148. #  backslash-quoted, as above.  No other characters are special or need quoting
  149. #  with that word.  The quoted delimiters are unquoted in the list of words 
  150. #  returned.  
  151. #
  152. proc parseWords {entry} {
  153.     set slash "¥¥"
  154.     set qslash "¥¥¥¥"
  155.     
  156.     set words {}
  157.     set entry [string trim $entry]
  158.  
  159.     while {[string length $entry]} {
  160.         set delim [string range $entry 0 0]
  161.         set entry [string range $entry 1 end]
  162.  
  163. #        regexp $endPat   matches the end of the word
  164. #               $openPat  matches the open delimiter
  165. #               $unescPat matches escaped instances of the open/close delimiters
  166. #
  167. #        $type == "quote" means open/close delimiters are the same
  168. #              == "paren" means there's a close delimiter and nesting is possible
  169. #              == "unquoted" means the word is delimited by whitespace.
  170. #
  171.         if {$delim == {"}} {            set endPat {^([^"]*)"}
  172.                                         set unescPat {¥¥(")}
  173.                                         set type quote
  174.             
  175.         } elseif {$delim == {'}} {        set endPat {^([^']*)'}
  176.                                         set unescPat {¥¥(')}
  177.                                         set type quote
  178.             
  179.         } elseif {$delim == "¥{"} {        set endPat "^(¥[^¥}¥]*)¥}"
  180.                                         set openPat "¥{"
  181.                                         set unescPat "¥¥¥¥(¥[¥{¥}¥])"
  182.                                         set type paren
  183.             
  184.         } elseif {$delim == "("} {        set endPat {^([^)]*)¥)}
  185.                                         set openPat {(}
  186.                                         set unescPat {¥¥([()])}
  187.                                         set type paren
  188.                                         
  189.         } else {                        set type unquoted
  190.         }
  191.         
  192.         if {$type == "quote"} {
  193.             set ck $qslash
  194.             set fld ""
  195.             while {$ck == $qslash} {
  196.                 set ok [regexp -indices $endPat $entry mtch sub1]
  197.                 if {$ok} {
  198.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  199.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  200.                     set pos [expr 1 + [lindex $mtch 1]]
  201.                     set entry [string range $entry $pos end]
  202.                 } else {
  203.                     error "Couldn't match $delim as field delimiter"
  204.                 }
  205.             }
  206.             set pos [expr [string length $fld] - 2]
  207.             set fld [string range $fld 0 $pos]
  208.             regsub -all $unescPat $fld {¥1} fld
  209.            
  210.         } elseif {$type == "paren"} {
  211.         
  212.             set nopen 1
  213.             set nclose 0
  214.             set fld ""
  215.             while {$nopen - $nclose != 0} {
  216.                 set ok [regexp -indices $endPat $entry mtch sub1]
  217.                 if {$ok} {
  218.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  219.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  220.                     set entry [string range $entry [expr 1 + [lindex $mtch 1]] end]
  221.                     regsub -all $unescPat $fld {} fld1
  222.                     set nopen [llength [split $fld1 $openPat]]
  223.                     if {$ck != $qslash} { incr nclose }
  224.                 } else {
  225.                     error "Couldn't match $delim as field delimiter"
  226.                 } 
  227.             }
  228.             set pos [expr [string length $fld] - 2]
  229.             set fld [string range $fld 0 $pos]
  230.             regsub -all $unescPat $fld {¥1} fld
  231.  
  232.         } elseif {$type == "unquoted"} {
  233.         
  234.             set entry ${delim}${entry}
  235.             set ok [regexp -indices {^([^     ]*)} $entry mtch sub1]
  236.             if {$ok} {
  237.                 set fld [string range $entry [lindex $sub1 0] [lindex $sub1 1]]
  238.                 set pos [expr 1 + [lindex $mtch 1]]
  239.                 set entry [string range $entry $pos end]
  240.             } else {
  241.                 set fld ""
  242.                 set entry ""
  243.             }
  244.         } else {
  245.             error "parseWords: unrecognized case"
  246.         }
  247.     
  248.         lappend words $fld
  249.         set entry [string trimleft $entry]
  250.     }
  251.     return $words
  252. }
  253.  
  254. ## 
  255.  # -------------------------------------------------------------------------
  256.  # 
  257.  #    "buildSubMenu" --
  258.  # 
  259.  #     Given a list of folders, 'buildSubMenu' returns a hierarchical    menu based 
  260.  #     on    the    files and subfolders in    each of    these folders.    Pathnames are 
  261.  #     optionally    stored in a    global array given by the argument 'filePaths'.     
  262.  #     The path's    index in this array    is formed by concatenating the submenu 
  263.  #     name and the filename,    allowing the pathname to be    retrieved by the 
  264.  #     procedure 'proc' when the menu    item is    selected.
  265.  # 
  266.  #     The search    may    be restricted to files with    specific extensions, or    files 
  267.  #     matching a    certain    pattern.  A    search depth may also be given,    with three 
  268.  #     levels    of subfolders assumed by default.
  269.  # 
  270.  #     See MacPerl.tcl or    latexMenu.tcl for examples.
  271.  # 
  272.  #     (originally written by    Tom    Pollard, with modifications    by Vince Darley    
  273.  #     and Tom Scavo)
  274.  # 
  275.  # --Version--Author------------------Changes-------------------------------
  276.  #      1.0      Tom Pollard                    original
  277.  #      2.0      <vince@das.harvard.edu> multiple extensions, optional    paths
  278.  #      2.1      Tom Scavo                        multiple folders
  279.  #      2.2      <vince@das.harvard.edu> pattern matching as well as exts
  280.  #      2.3      <vince@das.harvard.edu> handles unique menu-names and does text only
  281.  # -------------------------------------------------------------------------
  282.  ##
  283. proc buildSubMenu {folders name proc {filePaths ""} {exts ""} {depth 3} {fset ""}} {
  284.     global filesetFlags
  285.     if { $filePaths != "" } {
  286.         global $filePaths
  287.     }
  288.     
  289.     incr depth -1
  290.     set overallMenu {}
  291.     foreach folder $folders {
  292.         if {[file exists $folder]} {
  293.             if {![file isdirectory $folder]} {
  294.                 set folder "[file dirname $folder]:"
  295.             }
  296.             if {[string length [file tail $folder]] > 0} {
  297.                 set folder "$folder:"
  298.             }
  299.             if {$name == 0} {
  300.                 set name [file tail [file dirname $folder]]
  301.             }
  302.             # if it's a fileset, we register _before_ recursing
  303.             if { $fset != "" } {
  304.                 set mname [registerFilesetMenuName $fset $name $proc]
  305.             } else {
  306.                 set mname $name
  307.             }
  308.             set menu {}
  309.           if $filesetFlags(includeNonTextFiles) {
  310.               set filenames [glob -nocomplain ${folder}*]
  311.           } else {
  312.               set filenames [lsort -ignore [concat [glob -nocomplain ${folder}*:] ¥
  313.                   [glob -nocomplain -t TEXT ${folder}*]]] 
  314.           }
  315.             if {[llength $filenames] > 0} {
  316.                 foreach m $filenames {
  317.                     if {[file isdirectory $m] && $depth > 0} {
  318.                         set subM [buildSubMenu [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  319.                         if { $subM != "" } { lappend menu $subM }
  320.                     } elseif {[file isfile $m]} {
  321.                         set fname [file tail $m]
  322.                         if { $exts == "" || [lsearch ${exts} [file extension $fname] ] != -1 ¥
  323.                                  || [string match $exts $fname] } {
  324.                             lappend menu $fname
  325.                             if { $filePaths != "" } {
  326.                                 set ${filePaths}($name:$fname) $m
  327.                             }
  328.                         }
  329.                     }
  330.                 }
  331.             }                      
  332.             
  333.             if { $menu != "" } {
  334.                 set overallMenu [concat $overallMenu $menu]
  335.             }
  336.         } else {
  337.             beep
  338.             alertnote "buildSubMenu:  Folder $folder does not exist!"
  339.         }
  340.     }
  341.     
  342.     if { $overallMenu != "" } {
  343.         if { [string length $proc] > 1 } {
  344.             set pproc "-p $proc"
  345.         } else {
  346.             set pproc ""
  347.         }    
  348.         if { $fset != "" } {
  349.             if { [string length $proc] > 1 } { set pproc "-p subMenuProc" }
  350.         }     
  351.         return [concat {menu -m -n} [list $mname] $pproc [list $overallMenu]]
  352.         
  353.     } else {
  354.         return ""
  355.     }
  356. }
  357.  
  358. # in case we've done something odd elsewhere
  359. if ![info exists filesetFlags(includeNonTextFiles)] { 
  360.     set filesetFlags(includeNonTextFiles) 0
  361. }
  362.  
  363. #############################################################################
  364. # Return a list of all subfolders found within $folder,
  365. # down to some maximum recursion depth.  The top-level
  366. # folder is not included in the returned list.
  367. #
  368. proc listSubfolders {folder {depth 3}} {
  369.     set folders {}
  370.     if {$depth > 0} {
  371.         incr depth -1
  372.         if {[string length [file tail $folder]] > 0} {
  373.             set folder "$folder:"
  374.         }
  375.         foreach m [glob -nocomplain  $folder¥*] {
  376.             if {[file isdirectory $m]} {
  377.                 set folders [concat $folders [list $m]]
  378.                 set folders [concat $folders [listSubfolders ${m}: $depth]]
  379.             }
  380.         }
  381.     }
  382.     return $folders
  383. }
  384.  
  385. #############################################################################
  386.  
  387. proc commandClick {from to url} {
  388.     select $from
  389.     for {set i 0} {$i < 200} {incr i} {}
  390.     select $from $to
  391.     for {set i 0} {$i < 200} {incr i} {}
  392.     select $from
  393.     for {set i 0} {$i < 200} {incr i} {}
  394.     select $from $to
  395.     icURL $url
  396. }    
  397.  
  398.  
  399.